home *** CD-ROM | disk | FTP | other *** search
/ CD Actual 44 / PC Actual CD 44.iso / Linux / Cygwin / full.exe / Disk1 / data1.cab / Tools / share / itcl1.5 / itcl_mkindex.tcl < prev    next >
Encoding:
Text File  |  1998-12-04  |  3.4 KB  |  91 lines
  1.  
  2. # itcl_mkindex:
  3. # Regenerate a tclIndex file from Tcl source files.  Takes as argument
  4. # the name of the directory in which the tclIndex file is to be placed,
  5. # floowed by any number of glob patterns to use in that directory to
  6. # locate all of the relevant files.
  7. #
  8. # ////////////////////////////////////////////////////////////////////////
  9. #                MODIFIED TO RECOGNIZED [incr Tcl] CLASSES
  10. # ////////////////////////////////////////////////////////////////////////
  11. #
  12. #   AUTHOR:  Michael J. McLennan       Phone: (610)712-2842
  13. #            AT&T Bell Laboratories   E-mail: michael.mclennan@att.com
  14. #
  15. #      RCS:  itcl_mkindex.tcl,v 1.1.1.1 1994/03/21 22:09:46 mmc Exp
  16. # ----------------------------------------------------------------------
  17. #               Copyright (c) 1993  AT&T Bell Laboratories
  18. # ======================================================================
  19. # Permission to use, copy, modify, and distribute this software and its
  20. # documentation for any purpose and without fee is hereby granted,
  21. # provided that the above copyright notice appear in all copies and that
  22. # both that the copyright notice and warranty disclaimer appear in
  23. # supporting documentation, and that the names of AT&T Bell Laboratories
  24. # any of their entities not be used in advertising or publicity
  25. # pertaining to distribution of the software without specific, written
  26. # prior permission.
  27. #
  28. # AT&T disclaims all warranties with regard to this software, including
  29. # all implied warranties of merchantability and fitness.  In no event
  30. # shall AT&T be liable for any special, indirect or consequential
  31. # damages or any damages whatsoever resulting from loss of use, data or
  32. # profits, whether in an action of contract, negligence or other
  33. # tortuous action, arising out of or in connection with the use or
  34. # performance of this software.
  35. # ======================================================================
  36.  
  37. proc itcl_mkindex {dir args} {
  38.     global errorCode errorInfo
  39.     set oldDir [pwd]
  40.     cd $dir
  41.     set dir [pwd]
  42.     append index "# Tcl autoload index file, version 2.0\n"
  43.     append index "# This file is generated by the \"itcl_mkindex\" command\n"
  44.     append index "# and sourced to set up indexing information for one or\n"
  45.     append index "# more commands.  Typically each line is a command that\n"
  46.     append index "# sets an element in the auto_index array, where the\n"
  47.     append index "# element name is the name of a command and the value is\n"
  48.     append index "# a script that loads the command.\n\n"
  49.     if {$args == ""} {
  50.     set args *.tcl
  51.     }
  52.     foreach file [eval glob $args] {
  53.     set f ""
  54.     set error [catch {
  55.         set f [open $file]
  56.         while {[gets $f line] >= 0} {
  57.         if [regexp {^[     ]*proc[     ]+([^     ]*)} $line match procName] {
  58.             append index "set [list auto_index($procName)]"
  59.             append index " \[list source \[file join \$dir [list $file]\]\]\n"
  60.         }
  61.         if [regexp {^itcl_class[     ]+([^     ]*)} $line match className] {
  62.             append index "set [list auto_index($className)]"
  63.             append index " \[list source \[file join \$dir [list $file]\]\]\n"
  64.         }
  65.         }
  66.         close $f
  67.     } msg]
  68.     if $error {
  69.         set code $errorCode
  70.         set info $errorInfo
  71.         catch {close $f}
  72.         cd $oldDir
  73.         error $msg $info $code
  74.     }
  75.     }
  76.     set f ""
  77.     set error [catch {
  78.     set f [open tclIndex w]
  79.     puts $f $index nonewline
  80.     close $f
  81.     cd $oldDir
  82.     } msg]
  83.     if $error {
  84.     set code $errorCode
  85.     set info $errorInfo
  86.     catch {close $f}
  87.     cd $oldDir
  88.     error $msg $info $code
  89.     }
  90. }
  91.